


; to profile:
; (require profile)
; (profile-thunk (lambda () ... )


; PERFORMANCE/ELEGANCE

; pass collision masks to created objects where possible (where size are equal)

; remove unecessary (when *debug* ... )

; auto add to collision-list in world::update?

; the damage object created by destruction interacts with the destruction object also created
; not a bug per se, because it works as it should but it decreases performance

; when change is pressed we instanciate an object of the current weapon class every frame just to get its name (player::draw)
; a shame we dont have static methods
; cache an object of the currently selected weapon type, that way we can look up fire-rates and so on as well


; POTENTIAL BUGS

; race conditions occur when code executed as a result of user input (original thread) changes things used in the game loop (forked thread)
; this happens especially often when changing menu states
; it wouldnt be a problem if scheme let us allocate execution time for GUI when we wanted (like a handle-messages procedure)
; we have however decided that syncronization of cuncurrent threads is to be considered beyond the scope of this course

; only allow extension as tag if its at the end in graphics-cache


; FEATURES

; grenade could rotate based on collision, reaction and velocity (store momentum private var, anim updated in update)

; splinters, blood



; IDEAL

; hack together some sort of multiple inheritence.. would make things simpler

; encapsulation would benefit from having an "added" method in physics-object that notifies the object of it being added to a world
; since we only have one world this seemed as a bit of overkill and we simply use a global *world* var


; CONVENTIONS

; set-field! doesnt seem to work on older versions of DrScheme, dont use it
; this warrants removal of get-field as well - stick to good old get/seters









(define (vector-copy v)
  (let ([len (vector-length v)]
        [copy (make-vector (vector-length v))])
    (let loop ([i 0])
      (unless (= i len)
        (vector-set! copy i (vector-ref v i))
        (loop (add1 i))))
    copy))



; Update
    (define/public (update)
      ; 1. Fill map-collision and generate reaction vectors for new position (for objects collided with as well as the current object)
      (mfor-each (lambda (object)
                   (let* ([new-position (vector-op + (send object get-position)
                                                   (vector-scalar-op * (send object get-velocity) *time-delta*))]
                          [new-pos-x (inexact->exact (truncate (get-x new-position)))]
                          [new-pos-y (inexact->exact (truncate (get-y new-position)))]
                          [center-x  (fxquotient (get-x (send object get-size)) 2)]
                          [center-y  (fxquotient (get-y (send object get-size)) 2)])
                     (for ([x (in-range (- center-x) center-x)])
                       (for ([y (in-range (- center-y) center-y)])
                         (let ([collision (get-collision (+ x new-pos-x) (+ y new-pos-y))])
                           (if (eq? 'empty collision)
                               ; if empty, fill with object
                               (when (send object solid?) (set-collision (+ x new-pos-x) (+ y new-pos-y) object))
                               ; else generate reaction
                               (begin
                                 ; this object
                                 (send object set-collide #t)
                                 (when (send object bounce?)
                                   (send object set-reaction (vector-op fl+ (send object get-reaction) (vector (fl- #i-1/2 (fixnum->flonum x))
                                                                                                               (fl- #i-1/2 (fixnum->flonum y))))))
                                 ; other object (the length of the reaction vector is based on THIS object, but it will do)
                                 (when (object? collision)
                                   (send collision set-collide #t)
                                   (when (send collision bounce?)
                                     (send collision set-reaction (vector-op fl+ (send collision get-reaction) (vector (fl+ #i-1/2 (fixnum->flonum x))
                                                                                                                       (fl+ #i-1/2 (fixnum->flonum y))))))
                                   ; add to collision lists
                                   (unless (member collision (send object    get-collision-list))
                                     (send object    set-collision-list (cons collision (send object get-collision-list))))
                                   (unless (member object    (send collision get-collision-list))
                                     (send collision set-collision-list (cons object    (send object get-collision-list))))))))))))
                 objects)
      ; 2. Respond to collisions and reaction vectors, update objects and clear map-collision 
      (set! new-object #f)
      (let object-loop ([current objects] [prev #f])
        (unless (null? current)
          (let* ([object (mcar current)]
                 [new-velocity (vector-op + (send object get-velocity)
                                          (vector-scalar-op * (send object get-acceleration) *time-delta*))]
                 [new-position (vector-op + (send object get-position)
                                          (vector-scalar-op * (send object get-velocity)     *time-delta*))]
                 [new-pos-x (inexact->exact (truncate (get-x new-position)))]
                 [new-pos-y (inexact->exact (truncate (get-y new-position)))]
                 [center-x  (fxquotient (get-x (send object get-size)) 2)]
                 [center-y  (fxquotient (get-y (send object get-size)) 2)])
            ; check collision
            (when (send object get-collide)
              (when (send object bounce?)
                ; bounce if reaction is not zero
                (when (not (and (fl= #i0 (get-x (send object get-reaction))) (fl= #i0 (get-y (send object get-reaction)))))
                  (set! new-velocity (vector-scalar-op fl* (vector-mirror new-velocity (send object get-reaction)) *bounce-dampening*)))
                (set! new-position (send object get-position))))
            ; set position and velocity
            (send object set-position new-position)
            (send object set-velocity new-velocity)
            ; call object update (the lambdas are needed to create closures to store 'this')
            (unless (send object update (lambda (x y) (get-collision x y)) (lambda (x y radious) (destroy x y radious)))
              ; and remove from list if it returns #f
              ; update prev in case we're at the beginning of the list and new objects have been added in update
              (when (and (not prev) new-object)
                (set! prev new-object))
              (if prev
                  (set-mcdr! prev    (mcdr current))
                  (set!      objects (mcdr current))))
            ; remove map-collision entries for new position added in step 1
            (for ([x (in-range (- center-x) center-x)])
              (for ([y (in-range (- center-y) center-y)])
                (when (eq? object (get-collision (+ x new-pos-x) (+ y new-pos-y)))
                  (set-collision (+ x new-pos-x) (+ y new-pos-y) 'empty))))
            ; reset vars for next frame
            (send object set-collision-list '())
            (when (send object get-collide)
              (send object set-collide #f)
              (send object set-reaction (vector #i0 #i0))))
          ; Loop to next object
          (object-loop (mcdr current) current)))
      ; return
      (not quit))





; String Until Char
(define (string-until-char str char)
  (let ([len (string-length str)])
    (let string-until-char-loop ([pos 0])
      (if (= pos len)
          #f
          (if (eq? char (string-ref str pos))
              (substring str 0 pos)
              (string-until-char-loop (add1 pos)))))))



 
    ; Allocate Frame
    (define (allocate-frame bitmaps degree frame)
      (let* ([vec (vector-ref bitmaps degree)]
             [ok (and vec (< frame (vector-length vec)))])
        (unless ok
          (vector-set! bitmaps degree (make-vector (add1 frame) #f))
          (when vec
            (vector-copy! (vector-ref bitmaps degree) 0 vec)))
        ok))



    ; Load Graphics
    (define/public (graphics-load)
      (when graphics-name
        ; check if we have loaded this before
        (let ([lookup (assoc graphics-name *graphics*)])
          (if lookup
              ; if we found something, store a reference to it
              (begin
                (when *debug* (display* "looked up graphics for \"" graphics-name "\"\n"))
                (set! bitmaps (cdr lookup)))
              ; else load
              (begin
                (when *debug* (display* "loading graphics for   \"" graphics-name "\"\n"))
                (let ([new-bitmaps (make-vector *num-degree-bitmaps* #f)])
                  ; loop through all files in *graphics-folder*
                  (for-each (lambda (filepath)
                              (let ([degree #f]
                                    [frame  #f]
                                    [file (path->string filepath)])
                                ; check name
                                (when (and (<= (add1 (string-length graphics-name)) (string-length file))
                                           (equal? graphics-name (substring file 0 (string-length graphics-name))))
                                  (set! file (substring file (add1 (string-length graphics-name))))
                                  ; check/set degree
                                  (set! degree (string-extract-number file))
                                  (when degree
                                    (set! file (substring file (add1 (string-length (number->string degree)))))
                                    ; check/set frame
                                    (set! frame (string-extract-number file))
                                    (when frame
                                      (set! file (substring file (string-length (number->string frame))))
                                      ; check file extension
                                      (when (equal? file *resource-file-extension*)
                                        ; load bitmap
                                        (let ([bitmap (make-object bitmap% (string-append *graphics-folder* (path->string filepath)) 'unknown/mask)]
                                              [degree-complement degree])
                                          ; (re)allocate and generate bitmaps for every quadrant
                                          (for ([mirror-x (vector #f #t)])
                                            (when mirror-x (set! degree-complement (- (/ *num-degree-bitmaps* 2) degree)))
                                            (for ([mirror-y (vector #f #t)])
                                              (when mirror-y (set! degree-complement (rotate-in-range *num-degree-bitmaps* (- degree-complement))))
                                              (unless (and (allocate-frame new-bitmaps degree-complement frame) (vector-ref (vector-ref new-bitmaps degree-complement) frame))
                                                (vector-set! (vector-ref new-bitmaps degree-complement) frame (bitmap-mirror-flip bitmap mirror-x mirror-y))))))))))))
                            (directory-list *graphics-folder*))
                  ; assign
                  (set! bitmaps new-bitmaps)
                  ; and store for later lookup
                  (set! *graphics* (cons (cons graphics-name new-bitmaps) *graphics*))))))
        ; set width and height to math first bitmap necessary
        (for ([frame-vec bitmaps])
          (when (and frame-vec (not (and width height)))
            (set! width  (send (vector-ref frame-vec 0) get-width))
            (set! height (send (vector-ref frame-vec 0) get-height))))
        ; if we want an own copy, allocate one
        (when own-copy
          (let ([lookup bitmaps])
            (set! bitmaps (vector-copy lookup))
            (vector-for-each (lambda (e i) (when e (vector-set! bitmaps i (vector-copy e)))) lookup)))))
    

; 1. Fill map-collision and generate reaction vectors for new position (for objects collided with as well as the current object)
(mfor-each (lambda (object)
             (send object physics-object-space
                   (vector-op + (send object get-position)
                              (vector-scalar-op * (send object get-velocity) *time-delta*))
                   (lambda (x y pos-x pos-y)
                     (let ([collision (get-collision (+ x pos-x) (+ y pos-y))])
                       (if (eq? 'empty collision)
                           ; if empty, fill with object
                           (when (send object solid?) (set-collision (+ x pos-x) (+ y pos-y) object))
                           ; else generate reaction
                           (begin
                             ; this object
                             (send object set-collide #t)
                             (when (send object bounce?)
                               (send object set-reaction (vector-op + (send object get-reaction) (vector (- -1/2 x) (- -1/2 y)))))
                             ; other object (the length of the reaction vector is based on THIS object, but it will do)
                             (when (object? collision)
                               (send collision set-collide #t)
                               (when (send collision bounce?)
                                 (send collision set-reaction (vector-op + (send collision get-reaction) (vector (+ -1/2 x) (+ -1/2 y))))))))))))
           objects)

; "active bounce"
;(send object set-velocity (vector-op + (vector-scalar-op / (send object get-reaction) (/ (vector-abs (send object get-reaction)) 8))
;                                       (vector-scalar-op * (vector-mirror new-velocity (send object get-reaction)) *bounce-dampening*)))


; "active bounce"
;(when (send collision bounce?)
;  (send collision set-velocity (vector-op + (send collision get-velocity) (vector-scalar-op / (send object get-velocity) *bounce-dampening*))))








; Mutable Remove
(define (mremove element list)
  (let loop ([current list]
             [prev '()])
    (unless (null? current)
      (when (eq? (mcar current) element)
        (if (null? prev)
            (set!      list (mcdr current))
            (set-mcdr! prev (mcdr current))))
      (loop (mcdr current) current)))
  list)

; Mutable Remove Last
(define (mremove-last list)
  (let loop ([current list]
             [prev '()])
    (if (null? (mcdr current))
        (if (null? prev)
            (set!      list '())
            (set-mcdr! prev '()))
        (loop (mcdr current) current)))
  list)


; collisions with world
(let x-loop ((x 0))
  (unless (or (>= x size-x) (and no-bounce collide))
    (let y-loop ((y 0))
      (unless (or (>= y size-y) (and no-bounce collide))
        (let ([collision (lookup-collision (+ x pos-x) (+ y pos-y))])
          (unless (eq? 'empty collision)
            (set! collide #t)
            (set-field! reaction-vector object (vector-op + (get-field reaction-vector object) (vector (- center-x x) (- center-y y))))))
        (y-loop (add1 y))))
    (x-loop (add1 x))))

; collisions with other objects
(when #f
  (let collision-loop ([other-objects objects])
    (unless (null? other-objects)
      (let* ([other-object (mcar other-objects)]
             [collision-vector (vector-op - (get-field position other-object) new-position)])
        (when (and (not (eq? other-object object))
                   (< (vector-abs collision-vector)
                      (/ (+ (get-x (get-field size other-object)) size-x) 4)))
          (display "c")
          (set! collide #t)
          (set! no-bounce (and no-bounce (get-field no-bounce other-object)))
          (unless no-bounce
            (set! reaction-vector (vector-op + reaction-vector collision-vector)))))
      (collision-loop (mcdr other-objects)))))

            
            


; Extracts the bytes from a bitmap% object
(define (extract-bitmap-pixels bitmap)
  (let ((res (make-bytes (* 4 (send bitmap get-width) (send bitmap get-height)))))
    (send bitmap get-argb-pixels 0 0 (send bitmap get-width) (send bitmap get-height) res)
    res))

; alpha channel tests
(when #f
  (let ((bitmap (make-object bitmap% "maps/test.png" 'unknown/mask)))
    (let ((width  (send bitmap get-width))
          (height (send bitmap get-height)))
      (let ((argb-data (make-bytes (* 4 width height))))
        (send bitmap get-argb-pixels 0 0 width height argb-data #t)
        (let loop ([i 0])
          (when (< i (* 4 width height))
            (display (bytes-ref argb-data i))
            (display " ")
            (loop (add1 i))))))))



; world::update
               
            (when (< i (* (get-x size) (get-y size)))
              (if (not (eq? 'empty (vector-ref map-collision
                                               (+ (remainder i (get-x size)) (* y (get-width map))))))
              
                          
                          
                          
          (let loop ((x (- (get-x position) (get-x center)))
                     (y (- (get-y position) (get-y center))))
            (when (< y (get-field size object))
              (when (> x (get-x (get-field size object)))
                (set! y (+ 1 y))
                (set! x (- (get-x position) (get-x center))))
              (if (not (eq? 'empty (vector-ref map-collision (+ x (* y (get-width map))))))
                  
                  
                  
; grayscale test                  
(define b (make-object bitmap% "maps/pinetree_collision.png"))
(define by (make-bytes (* 4 1 1)))
(send b get-argb-pixels 283 329 1 1 by)

(display (bytes->list by))



; Loop x & y

(when #f
(let x-loop ((x 0))
  (when (< (- x 0) 5)
    (let y-loop ((y 0))
      (when (< (- y 0) 5)
        (display* x " " y "\n")
        (y-loop (+ 1 y))))
    (x-loop (+ 1 x)))))


; collision tests

       ; (display* (bytes-ref collision-data (* 4 (+ 338 (* 226 width)))) " ")
       ; (display* (bytes-ref collision-data (* 4 (+ 350 (* 350 width)))) " ")
       ; (display* (bytes-ref collision-data (* 4 (+ 30  (* 30  width)))) " ")
          ; test
          ;(display (vector-ref map-collision (+ 338 (* 226 width))))
          ;(display (vector-ref map-collision (+ 350 (* 350 width))))
          ;(display (vector-ref map-collision (+ 30  (* 30  width))))



; world collision (object bitmap rect)

          ;(display* center " " new-position " " delta-vector " " (get-field velocity object) " " (get-field acceleration object) "\n)")
          ; sum up accumulated collisions for new position
;          (let loop ((x x-start)
;                     (y y-start))
;            (when (< (- y y-start) (get-y size))
;              (when (not (eq? 'empty (vector-ref frame-collision (point->index x y (send map get-width)))))
;                (display* x " " y "\n")
;                (set! collision-vector (vectors-op + collision-vector (vector (- x (get-x new-position)) (- y (get-y new-position)))))
;                (set! collide? #t))
;              (set! x (+ 1 x))
;              (when (not (< (- x x-start) (get-x size)))
;                (set! y (+ 1 y))
;                (set! x x-start))
;              (loop x y)))
;          
          



; Longer version that seperates rgb and alpha more than necessary

(define (bitmap-op bitmap . ops)
  (let* ((flip   #f)
         (mirror #f)
         (width  (send bitmap get-width))
         (height (send bitmap get-height))
         (read   (make-bytes (* 4 width height)))
         (write  (make-bytes (* 4 width height)))
         (dc     (create-object bitmap-dc%)))
    ; set pixel helper
    (define (set-pixel x y . bytes)
      (for-each (lambda (b)
                  (byte-set! write (+ b (point->index x y width)) (byte-ref read (+ b (point->index (if mirror (- width x) x) (if flip (- height y) y) width)))))
                bytes))
    ; process helper
    (define (process alpha)
      (let x-loop ((x 0))
        (when (< x width)
          (let y-loop ((y 0))
            (when (< y height)
              (set-pixel x y (if alpha (list 0) (list 1 2 3)))
              (y-loop (add1 y))))
          (x-loop (add1 x)))))
    ; parse ops
    (for-each (lambda (op)
                (cond ((eq? op 'flip)   (set! flip   #t))
                      ((eq? op 'mirror) (set! mirror #t))
                      (else (error "bitmap-op got usupported op") (error op))))
              ops)
    ; process rgb and alpha seperately (get-argb-pixels is kind of dumb..)
    (for-each (lambda (alpha)
                (send bitmap get-argb-pixels 0 0 width height read  alpha)
                (process alpha)
                (send dc     set-argb-pixels 0 0 width height write alpha))
              (#t #f))
    ; return the resulting bitmap
    (send dc get-bitmap)))







;
; OLD VECTOR FUNCTIONS
;

; Applies "op" to every element with position "element" in each vector in the "vector-list" and returns the result
; (vectors-element-op + 0 (list (vector 1 2) (vector 3 4))) -> 4
(define (vectors-element-op op element vector-list)
  (define (loop op element vector-list element-res)
    (if (null? vector-list)
        element-res
        (loop op element (cdr vector-list) (op element-res (vector-ref (car vector-list) element)))))
  (loop op element (cdr vector-list) (vector-ref (car vector-list) element)))

; Creates a new vector where each element is "op" applied to the respective elements in the "vector-list"
; (vectors-op + #(1 2) #(3 4)) -> #(4 6)
(define (vectors-op op . vector-list)
  (define (loop op vector-list element vector-res)
    (if (= element (vector-length (car vector-list)))
        vector-res
        (begin 
          (vector-set! vector-res element (vectors-element-op op element vector-list))
          (loop op vector-list (+ 1 element) vector-res))))
  (loop op vector-list 0 (make-vector (vector-length (car vector-list)))))

; Applies "op" between each element in the vector and returns the result
; (elements-op + (vector 1 2 3)) -> 6
(define (elements-op op vector)
  (define (loop op element element-res)
    (if (= element (vector-length vector))
        element-res
        (loop op (+ 1 element) (op element-res (vector-ref vector element)))))
  (loop op 1 (vector-ref vector 0)))







; Make Sequential Asociacion List
(define (make-seq-alist start . args)
  (let loop ((pos start)
             (symbol-list args)
             (res '()))
    (if (null? symbol-list)
        res
        (loop (add1 pos) (cdr symbol-list) (cons (cons (car symbol-list) pos) res)))))

; Key -> Integer
(define (key->integer key)
  (if (symbol? key)
      (cdr (assq key *key-symbols*))
      (char->integer key)))

; http://download.plt-scheme.org/doc/4.2.4/html/gui/key-event_.html
(define *key-symbols* (make-seq-alist 256
                                        'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital 'prior 'next 'end 'home
                                        'left 'up 'right 'down
                                        'escape 'select 'print 'execute 'snapshot 'insert 'help
                                        'numpad0 'numpad1 'numpad2 'numpad3 'numpad4
                                        'numpad5 'numpad6 'numpad7 'numpad8 'numpad9
                                        'numpad-enter 'multiply 'add 'separator 'subtract 'decimal 'divide
                                        'f1 'f2 'f3 'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12
                                        'f13 'f14 'f15 'f16 'f17 'f18 'f19 'f20 'f21 'f22 'f23 'f24
                                        'numlock 'scroll))

; user-interface private variable
(define keys (make-vector (+ 256 (length *key-symbols*)) #f))






; code to rotate bitmap 90 degrees
; by Matthew Flatt mflatt at cs.utah.edu
; obtained from http://list.cs.brown.edu/pipermail/plt-scheme/2008-November/028559.html
; assumed public domain
(define (rotate-bm bm cw?)
  (let ([w (send bm get-width)]
        [h (send bm get-height)])
    (let ([bm2 (make-object mred:bitmap% h w)]
          [s (make-bytes (* w h 4))]
          [s2 (make-bytes (* h w 4))])
      (send bm get-argb-pixels 0 0 w h s)
      (for ([i (in-range w)])
        (for ([j (in-range h)])
          (let ([src-pos (* (+ i (* j w)) 4)])
            (bytes-copy! s2 
                         (if cw?
                             (* (+ (- (- h j) 1) (* i h)) 4) 
                             (* (+ j (* (- (- w i) 1) h)) 4))
                         s src-pos (+ src-pos 4)))))
      (let ([dc (make-object mred:bitmap-dc% bm2)])
        (send dc set-argb-pixels 0 0 h w s2)
        (send dc set-bitmap #f))
      bm2)))


